Komputer for Alle 2004 E…tra 100 Bedste Programmer/K-CD_2004_Ekstra_100_Gratis_Programmer.iso/Windows/X-Setup/xqdcXSP-Setup-EN.exe/{app}/plugins/svho IE Edit Context Menu.xpl

XSetup plugin | 2003-11-20 | 12.8 KB | 435 lines

"FILE"="Xteq Systems X-Setup Plugin 6.0"
"TYPE"="8"
"COUNT"="3"
"TEXT 1"="&Edit"
"TEXT 2"="&Add new"
"TEXT 3"="&Delete"
"UIPATH"="Internet\Internet Explorer\Context Menu Entries"
"NAME"="Editor"
"LANGUAGE"="VBScript"
"DESCRIPTION 1"="This plug-in edits entries in Internet Explorer context menu. You may need to restart Internet Explorer to make it work."
"DESCRIPTION 2"="NOTE #1: Entries, that begin with '[]' are unvisible."
"DESCRIPTION 3"="NOTE #2: Entries, that begin with '!!' are visible, but IE shows them not, because they are useless (without default URL)."
"DESCRIPTION 4"="NOTE #3: To only rename the entry, click 'Edit', change the name, click 'OK' and then 'Cancel'.
"VERSION"="1.02"
"AUTHOR"="Svyatoslav Holub"
"CONTACTURL"="mailto:[e-mail]"
"COPYRIGHT"="This plug-in is Freeware. Use at your own risk!"
"COMMENT 1"="Tested on Windows 98SE with Internet Explorer 6.0"
"ADMINRIGHTS"="0"
"OSVERSION"="0111111"

visibleMenuExt="HKCU\Software\Microsoft\Internet Explorer\MenuExt"
unvisibleMenuExt="HKCU\Software\Microsoft\Internet Explorer\MenuExt-"

const vMark ="[] "  'indicates unvisibility
const uMark ="!! "              'indicates useless

dim visibleCount, unvisibleCount
dim visibleMenuExists, unvisibleMenuExists
dim vMarkLength, uMarkLength
dim trueNames()


Sub Plugin_Initialize
 vMarkLength = Len(vMark)
 uMarkLength = Len(uMark)

'Clear listbox
 elemNumber = visibleCount + unvisibleCount
 For l = 1 to elemNumber
   SetUIElement l, ""
 Next

'Clear names array
 Redim trueNames(0)

 visibleCount = 0
 unvisibleCount = 0


 visibleMenuExists = RegPathExists(visibleMenuExt)
 unvisibleMenuExists = RegPathExists(unvisibleMenuExt)

 dim  falseNames
 If  visibleMenuExists = true Then
  visibleCount=RegEnumPaths(visibleMenuExt)
  If CBool (visibleCount) Then listAddNew visibleCount, 0, true, falseNames
 End If

 If  unvisibleMenuExists = true Then
  unvisibleCount=RegEnumPaths(unvisibleMenuExt)
  If CBool (unvisibleCount) Then listAddNew unvisibleCount, visibleCount, false, falseNames
 End If

 If falseNames <> "" Then MsgWarning "Following context menu names begin with " & _
          vMark & "or " & uMark & ":" & vbCrLf & vbCrLf & _
          falseNames & vbCrLf & "The plug-in uses this characters " & _
          "to indicate entry properties." & vbCrLf & _
          "Please rename this entries with 'Edit'-button."
 'If visibleCount + unvisibleCount = 0 Then Disable
End Sub

Sub listAddNew (elemCounter, listCounter, visibilityFlag, ByRef falseNames)
 For i=1 to elemCounter
   extText=RegEnumElement(i)
   j = i + listCounter
   Redim Preserve trueNames(j)
   trueNames(j) = extText
   If Len(extText) > 1 Then _
     If Left(extText,2)=Left(uMark,2) OR Left(extText,2)=Left(vMark,2) Then _
       falseNames = falseNames & vbTab & extText & vbCrLf
   If visibilityFlag = false Then
       SetUIElement j, vMark & extText
   Else
       If RegReadValue(visibleMenuExt & "\" & extText & "\" & "@")="" Then
        SetUIElement j, uMark & extText
       Else
        SetUIElement j, extText
       End If
   End If
 Next
End Sub


Sub Plugin_Apply(ElementIndex,ElementSubIndex)
'Nothing to do, if IE settings in Registry were meantime for example manual changed.
 If RegistryChanged = true Then Exit Sub

 Select Case ElementIndex
 Case 1 'edit
  If ElementSubIndex <> 0 Then editEntry ElementSubIndex
 Case 2 'add new
  addEntry
 Case 3 'delete
  If ElementSubIndex <> 0 Then deleteEntry ElementSubIndex
 Case Else
  'not possible
 End Select

End Sub


Sub editEntry (entryIndex)

changed = false

If entryIndex <> 0 Then
  If entryIndex > visibleCount Then
    fullName = unvisibleMenuExt & "\" & trueNames(entryIndex)
    visibility = false
  Else
    fullName = visibleMenuExt & "\" & trueNames(entryIndex)
    visibility = true
  End If
Else
  visibility = true
End If

  dim editValues(3)
  editValues(3) = visibility

  'show input windows
  For i=1 to 4
    answer = DataInput (i, fullName, entryIndex, editValues)
    If IsEmpty(answer) = true Then Exit For
  Next

  If IsEmpty(editValues(0)) = true Then Exit Sub

  If editValues(0) <> trueNames(entryIndex) OR editValues(3) <> visibility Then
    If editValues(3) = true Then _
        fullDestination = visibleMenuExt & "\" & editValues(0) Else _
        fullDestination = unvisibleMenuExt & "\" & editValues(0)
    If RegistryChanged = true Then Exit Sub
    If entryIndex <> 0 Then moveSubKey  fullName, fullDestination _
    Else RegWriteValue fullDestination & "\@", "", 1
    changed = true
    fullName = fullDestination
  End If

  If IsEmpty(editValues(1)) = true Then
    If changed = true Then
      IndicateSettingChange
      Plugin_Initialize
    End If
    Exit Sub
  End If
  RegWriteValue fullName & "\@", editValues(1), 1

  If IsEmpty(editValues(2)) = true Then
    If changed = true Then
      IndicateSettingChange
      Plugin_Initialize
    End If
    Exit Sub
  End If
  If editValues(2) = "" Then
    If RegValueExists(fullName & "\contexts") = true Then _
    RegDeleteValue fullName & "\contexts"
  Else
    RegWriteValue fullName & "\contexts", editValues(2), 3
  End If

  If changed = true Then
    IndicateSettingChange
    Plugin_Initialize
  End If
End Sub


Sub addEntry
  editEntry 0
End Sub


Sub deleteEntry (entryIndex)
  If entryIndex > visibleCount Then
    deleteSubKey unvisibleMenuExt & "\" & trueNames(entryIndex)
  Else
    deleteSubKey visibleMenuExt & "\" & trueNames(entryIndex)
    IndicateSettingChange
  End If
 Plugin_Initialize
End Sub


'show input windows
'check, convert and save input values
Function DataInput(inputIndex, fullKeyName, namesIndex, ByRef values)
         'show input windows with values
  Select Case inputIndex
    Case 1          'entry name
     text = "Enter context menu name, which can include an ampersand character to cause " & _
            "the character that follows to be underlined and used as a shortcut key:"
  value = trueNames(namesIndex)
    Case 2          'default URL
     text = "Enter URL of the page that contains the script, which you want to execute:" & vbCrLf & _
            "(if URL is empty, IE shows this entry not!)"
     If namesIndex <> 0 Then value = RegReadValue(fullKeyName & "\@") _
     Else value = ""
    Case 3          'contexts
     text = "Which contexts this entry should appear? " & _
            "Use the logical OR of the following values:" & vbCrLf & _
            "00000001-default" & vbTab & "00001000-tables" & vbCrLf & _
            "00000010-images" & vbTab & "00010000-selection   " & vbCrLf & _
            "00000100-controls" & vbTab & "00100000-anchor"
      If namesIndex <> 0 Then
     If RegValueExists(fullKeyName & "\contexts")=true Then _
        valueType=RegValueType(fullKeyName & "\contexts")
        value = RegReadValue(fullKeyName & "\contexts")
     If value <> Empty Then
       'convert only last byte
       If valueType=3 Then value=CLng("&H" & Right(value,2))
       If valueType=2 OR valueType=3 Then value=dez2bin(value)
     Else
       value = ""
     End If
      Else
        value = "00000001"
      End If
    Case 4          'visibility
     text = "Are you want to make this entry visible (Yes/No)?"
     If namesIndex > visibleCount Then value = "No" Else value = "Yes"
    Case Else
     Err.Raise vbObjectError + 1, "Function DataInput", "inputIndex (" & inputIndex & ") is out of bound (4)!"
  End Select

  Do         'check input data
    reinput = false
    answer = InputWindow(text,value,1)
    If IsEmpty(answer) = true Then Exit Function

         'syntax check and data convert
    Select Case inputIndex
      Case 1          'entry name
        If Trim(answer) = "" Then
          reinput = true
        ElseIf Len(Trim(answer)) > 1 Then
          If Left(Trim(answer),2)=Left(uMark,2) OR Left(Trim(answer),2)=Left(vMark,2) Then
            MsgWarning "Names, which begin with " & _
                    uMark & "or " & vMark & _
                    "are not allowed!"
            reinput = true
          End If
        End If

        If reinput = false Then
          If LCase(answer) <> LCase(trueNames(namesIndex)) Then
            For c=1 To UBound(trueNames)
              If LCase(answer) = LCase(trueNames(c)) Then
                MsgWarning "This name already exists!"
                reinput = true
                Exit For
              End If
            Next
          End If
        End If
      Case 2          'default URL
        If Trim(answer) = "" AND answer <> "" Then reinput = true
      Case 3          'contexts
        If answer = "" Then
          'nothing to do
        ElseIf Len(answer)=8 Then
          For i=1 To Len(answer)
           char = Mid(answer,i,1)
           Select Case char
            Case "0", "1"
              filtredAnswer = filtredAnswer & char
            Case Else
              'nothing to do
           End Select
          Next
          If answer = filtredAnswer Then
            answer = bin2hex(answer)
          Else
            reinput = true
          End If
        Else
          reinput = true
        End If
      Case 4          'visibility
        If LCase(answer)="yes" Then
          answer = true
        ElseIf LCase(answer)="no" Then
          answer = false
        Else
          reinput = true
        End If
      Case Else
        'unpossible
    End Select
    value = answer
  Loop While reinput = true

  values(inputIndex-1) = answer

  DataInput = answer
End Function


Function bin2hex(binValue)
 For i=0 To 7
  dezValue = dezValue + Mid(binValue,8-i,1)*2^(i)
 Next
 bin2hex = Hex(dezValue)
 If Len(bin2hex) = 1 Then bin2hex = "0" & bin2hex
End Function


'convert only last byte
Function dez2bin(ByVal dezValue)
  For i=1 to 8
   bit = (dezValue Mod 2) & bit
   dezValue = dezValue \ 2
  Next
  dez2bin = bit
End Function


Sub moveSubKey (fullSourceKey, fullDestinationKey)
  dim i, j
  dim pathsCount, valuesCount
  dim defaultString, value, data, dataType

    pathsCount = RegEnumPaths(fullSourceKey)
    If pathsCount <> 0 Then
      For j=1 to pathsCount
       moveSubKey fullSourceKey & "\" & RegEnumElement(j), fullDestinationKey & "\" & RegEnumElement(j)
      Next
    End If

    defaultString = RegReadValue(fullSourceKey & "\@")
    RegWriteValue fullDestinationKey & "\@", defaultString, 1

    valuesCount = RegEnumValues(fullSourceKey)
    For i=1 to valuesCount
       value = RegEnumElement(i)
       data = RegReadValue(fullSourceKey & "\" & value)
       dataType = RegValueType(fullSourceKey & "\" & value)
       RegWriteValue fullDestinationKey & "\" & value, data, dataType
       RegDeleteValue fullSourceKey & "\" & value
    Next
    RegDeletePath fullSourceKey
End Sub


Sub deleteSubKey (fullName)
 dim x, y
 dim values, pathsCount
   pathsCount = RegEnumPaths(fullName)
   If pathsCount <> 0 Then
    For x=1 to pathsCount
     deleteSubKey fullName & "\" & RegEnumElement(x)
    Next
   End If

   values = RegEnumValues(fullName)
   For y=1 to values
    valueName = RegEnumElement(y)
    RegDeleteValue fullName & "\" & valueName
   Next
   RegDeletePath fullName
End Sub

'Check, if IE settings in Registry were meantime for example manual changed.
'If yes, plug-in restarts.
Function RegistryChanged
  If visibleMenuExists <> RegPathExists(visibleMenuExt) Then
      IndicateSettingChange
      RestartMessage
      RegistryChanged = true
      Exit Function
  ElseIf visibleMenuExists = true Then
      If visibleCount <> RegEnumPaths(visibleMenuExt) Then
 IndicateSettingChange
       RestartMessage
       RegistryChanged = true
       Exit Function
      End If
  End If

  If unvisibleMenuExists <> RegPathExists(unvisibleMenuExt) Then
      RestartMessage
      RegistryChanged = true
      Exit Function
  ElseIf unvisibleMenuExists = true Then
      If unvisibleCount <> RegEnumPaths(unvisibleMenuExt) Then
       RestartMessage
       RegistryChanged = true
       Exit Function
      End If
  End If

  For i=1 to visibleCount
    If RegPathExists(visibleMenuExt & "\" & trueNames(i)) = false Then
      IndicateSettingChange
      RestartMessage
      RegistryChanged = true
      Exit Function
    End If
  Next

  elCount = visibleCount + unvisibleCount
  For i=visibleCount + 1 to elCount
    If RegPathExists(unvisibleMenuExt & "\" & trueNames(i)) = false Then
      RestartMessage
      RegistryChanged = true
      Exit Function
    End If
  Next

  RegistryChanged = false
End Function


Sub RestartMessage
  Plugin_Initialize
  MsgWarning "Plug-in is restarted, because" & vbCrLf & _
        "Registry was changed!" & vbCrLf & "Your changes were not applied."
End Sub


Sub Plugin_Terminate
End Sub